home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol076 / xmodem.crc < prev    next >
Encoding:
Text File  |  1987-01-14  |  51.4 KB  |  1,699 lines
  1.  
  2. c    program xmodem50
  3.  
  4. c  ATTEMPTED TO USE LIB$CRC
  5. c  THIS DOES NOT WORK FOR UNKNOWN REASONS
  6.  
  7. c               MODEM7-type program to send and
  8. c               receive files with checksums or CRC and automatic
  9. c               re-transmission of bad blocks.
  10. c               translated to VAX Fortran V3.0 from TMODEM.C
  11. c               and enhanced according to time-outs and CRC
  12. c               in XMODEM50.ASM
  13. c               J.James Belonis II
  14. c               Physics Hall FM-15
  15. c               University of Washington
  16. c               Seattle, WA 98195
  17. c        (206) 545-8695
  18. c
  19. c  TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
  20. c   Weinstein
  21. c
  22. c  3/17/84 changed to LIB$CRC VAX system service.  Left old updcrc
  23. c               and associated routines in place, commented out.
  24. c  3/13/84 reserved space in cancel for eating characters to avoid access viol
  25. c  3/13/84 increased RECVFILE data block timeout to 2 sec
  26. c  2/27/84 Version 5.5 incorporated improvements by Steve Gill
  27. c        GETACK  timeout and garbage loop and NAK, CAN detection
  28. c        RECVFILE receive data block with timeout
  29. c               TTYIN routine removed since replaced everywhere by TTYINLIM
  30. c  1/25/84 properly placed CALL PASSALL in main program so not miss parity bit
  31. c        in sendfn filename checksum
  32. c  1/ 8/84 corrected last known bugs
  33. c  1/ 2/84 Version 5.4 Added batch
  34. c 12/31/83 Version 5.3 Added wildcard filenames(but not yet batch) and
  35. c        streamlined option parsing and allowed CRC TEXT
  36. c        found and fixed blank trim miscalculation
  37. c        again (CONN apparently got old version)
  38. c        XMODEM.LOG and XMODEM.WRK put in SYS$SCRATCH directory
  39. c        (usually user's main) if can't open in current directory
  40. c 12/27/83 Version 5.2 Speeded up SEND by doing only one TTYOUT call per block.
  41. c           no longer hogs CPU at 9600 baud (only 15-20 percent of cpu time)
  42. c           included QIO.DCK so only one file XMODEM.FOR is needed.
  43. c  6/30/83 Modified, restructured, and VAX/VMS text file
  44. c       conversion added by Richard Conn
  45. c  1/17/83      touched up filename display and comments.
  46. c  1/14/83      including timeouts and CTRL-X cancellation
  47. c               and CRC capability
  48. c
  49. c  keeps a log file of error messages ( deletes it if no errors )
  50. c  sets terminal driver to eightbit, passall
  51. c  may need altypeahd if faster than 1200 baud works to 9600 baud at least.
  52. c  needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
  53. c  nor on ACC VAX
  54. c  many debugging statements left in as comments
  55.  
  56. c  declare variables
  57.  
  58.     include  '($rmsdef)'    ! for LIB$FIND_FILE
  59.        INTEGER*2 CHAN,STATUS(4)
  60.        COMMON /QIO/ CHAN,STATUS
  61.  
  62.         character*128 line, filein, file, filec, filed, workf, options
  63.         integer seploc, worklen, context, istat, length, lengthin
  64.     logical openok, sendopt, recvopt, textopt
  65.     logical getfn, sendfn
  66.  
  67.     logical batchopt,firstbatch
  68.     common /batch/batchopt,firstbatch
  69.  
  70.         logical filedel
  71.         common /filest/filedel
  72.  
  73.         integer errorcount
  74.         common /err/errorcount
  75.  
  76.     integer*4 crctable(16),crclword,lib$crc
  77.         integer*2 highword  ! highword just spaceholder for crclword
  78.     byte highbyte,lowbyte
  79.         common /crcval/crctable,lowbyte,highbyte,highword
  80.     equivalence (lowbyte,crclword)
  81.  
  82. c  obsolete version will be useful for non-VAX implementations
  83. c        integer high,low
  84. c    byte highbyte,lowbyte
  85. c        common /crcval/high,low
  86. c    equivalence (high,highbyte)
  87. c    equivalence (low,lowbyte)
  88.  
  89.         logical crc
  90.         byte checksumbyte
  91.         integer checksum
  92.         common /checks/checksum,crc
  93.         equivalence (checksum,checksumbyte)
  94.  
  95.         equivalence (ic,c)
  96.  
  97. c  define ascii characters
  98.         parameter NUL=0         !ignore at SOH time
  99.         parameter SOH=1         !start of header for sector
  100.         parameter EOT=4         !end of transfer
  101.         parameter ACK=6         !acknowlege sector
  102.     parameter BEL=7        !bell warning if stupid
  103.         parameter NAK=21        !not acknowlege sector
  104.         parameter CAN=24        !cancel transfer
  105.         parameter CRCCHAR='C'   !CRC indicating character
  106.  
  107. c  timeouts
  108.         parameter respnaklim=10 !seconds to allow for response to NAK
  109.         parameter naklim=10     !seconds to allow to receive first NAK
  110.         parameter eotlim=10     !seconds to wait for EOT acknowlege
  111.  
  112.         parameter errlim=10     !max errors on a sector
  113.  
  114. c  define an exit routine to get control on all exits to turn off
  115. c  passall and for debug cleanup
  116.             external giveup
  117.         call userex( giveup )
  118.  
  119.         print *,' XMODEM Version 5.5 3/13/84 [BATCH capable]'
  120.  
  121. c  assign terminal channel for QIO calls to send raw bytes.
  122.         call sys$assign('TT',chan,,)
  123. c  construct CRC table for use by LIB$CRC()
  124.     call lib$crc_table( '102010'o, crctable )
  125.  
  126. c  get command line
  127.         call lib$get_foreign(line,'$_Command: ',,)
  128. c  trim blanks
  129.         do i=80,1,-1
  130.                 length=i
  131.                 if(line(i:i).NE.' ') goto 25
  132.         enddo
  133. c  no command on line
  134.   25    continue
  135.  
  136. c  separate options from filename
  137. c    print *,' length=',length
  138.     seploc = index( line(1:length+1),' ' ) ! +1 so find end if one argument
  139. c    print *,' seploc=',seploc
  140.     options=line(1:seploc-1)
  141.     filein=line(seploc+1:length)
  142. c    print *,'options*',options(1:seploc-1),'*'
  143.     lengthin=length-seploc
  144.     if(lengthin.gt.0) then    ! make sure not index infinite length string
  145.         if(  index( filein(1:lengthin), ' ' ) .ne. 0  ) then
  146. c        print *,'filein*',filein(1:lengthin),'*'
  147. c        print *,'index( filein,'' '')',index(filein(1:lengthin),' ')
  148.         print *,' too many arguments'
  149.         goto 150
  150.         endif
  151.     endif
  152.      
  153.         filedel=.false.
  154. c  parse the options
  155.     batchopt=.false.
  156.     firstbatch=.false.
  157.     textopt=.false.
  158.     sendopt=.false.
  159.     recvopt=.false.
  160.     crc=.false.
  161.     i=0
  162.     if( index(options,'B').NE.0 ) then
  163.         batchopt=.true.
  164.         firstbatch=.true.
  165.         i=i+1
  166.     endif
  167.     if( index(options,'T').NE.0 ) then
  168.         textopt=.true.
  169.         i=i+1
  170.     endif
  171.     if( index(options,'S').NE.0 ) then
  172.         sendopt=.true.
  173.         i=i+1
  174.     endif
  175.     if( index(options,'R').NE.0 ) then
  176.         recvopt=.true.
  177.         i=i+1
  178.     endif
  179.     if( index(options,'C').NE.0 ) then
  180.         crc=.true.
  181.         i=i+1
  182.     endif
  183.  
  184. c  check options
  185.     if(i.ne.seploc-1) then
  186.         print *,char(BEL),' unsupported options ignored'
  187.         print *
  188.     endif
  189.     if(sendopt.and.recvopt) then    ! send and receive simultaneously
  190.         print *,' incompatible options SEND and RECEIVE'
  191.         call exit
  192.     endif
  193.     if(  .not.(recvopt.and.batchopt) .and. lengthin.le.0 ) then
  194. c  no options or no filename
  195.         print *,' insufficient arguments'
  196.         goto 150
  197.     endif
  198.     if( lengthin.gt.0 .and. (recvopt.and.batchopt) ) then
  199.         print *,' filename ignored on batch receive',char(BEL)
  200.     endif
  201.  
  202.  
  203.     context=0    ! initial FAB pointer for LIB$FILE_FIND
  204.         call passall(CHAN,.TRUE.)    ! turn on passall so typeahead
  205.                     ! not strip parity on unsolicited chars
  206. c  BATCH option loop comes here
  207. 100    continue    !GOTO at end comes here for next filename
  208.  
  209. c  open separate log file for each transferred file.
  210.     openok=.true.
  211.     workf='XMODEM.WRK'
  212.     worklen=10
  213.     open(8,file='XMODEM.LOG', iostat=istat,
  214.      1                         carriagecontrol='LIST',status='NEW')
  215.     if(istat.ne.0) then
  216.         if(firstbatch) then
  217.         print *,' Can''t open XMODEM.LOG in this directory,'
  218.         print *,' putting it in your main directory.',char(BEL)
  219.             endif
  220.             open(8,file='SYS$SCRATCH:XMODEM.LOG',
  221.      1                         carriagecontrol='LIST',status='NEW')
  222.         openok=.false.
  223.         workf='SYS$SCRATCH:XMODEM.WRK'
  224.         worklen=22      ! number of chars in file name
  225.     endif
  226.  
  227.     if(recvopt) then        ! wildcards done on other computer
  228.         if(.not.batchopt) then
  229.             file=filein
  230.             length=lengthin
  231.         endif
  232.     else    ! sending, need name(s)
  233.         istat=lib$find_file(filein(1:lengthin),file,context,,)
  234.         if(istat.eq.rms$_nmf) then    ! no more files
  235.             if(batchopt) then !await rcvr's request for filename
  236.                 call waitnlp(80) 
  237.                 call ttyout(ACK,1)    ! tell yes file
  238.             endif
  239.             call ttyout(EOT,1)    ! tell other computer no more
  240.                         ! it receives EOT as first
  241.                         ! char of expected filename
  242. c                print *,' All transfers complete.'
  243.                     write(8,*) ' All transfers complete.'
  244.             close(8,dispose='delete')    ! .LOG file
  245.             call exit
  246.         endif
  247.         if(.not.istat) then
  248.             if(firstbatch.or..not.batchopt) then
  249.                 print *,' LIB$FILE_FIND error'
  250.             endif
  251.             write(8,*) ' LIB$FILE_FIND error'
  252.             call cancel
  253.         endif
  254. c  trim blanks
  255.             do i=128,1,-1
  256.                     length=i
  257.                     if(file(i:i).NE.' ') goto 125
  258.             enddo
  259. c        print *,' couldn''t happen, filename blank'
  260.         write(8,*) ' couldn''t happen, filename blank'
  261.  125        continue
  262.  
  263.     endif
  264.  
  265.     if( sendopt ) then
  266. c  send
  267.         if(batchopt) then
  268. c                                       make a reasonable filename
  269.             call cleansfn( file(1:length),filec,leng)
  270.             if(firstbatch) then
  271.               print *,' sending BATCH mode, please run receiver'
  272.             endif
  273.             call sendfn( filec(1:leng) )
  274.         endif
  275.         if(textopt) then
  276.             if(.not.batchopt) then    ! not batch
  277.                         print *,' Sending Text File: ',file(1:length)
  278.                 print *,' Do not run your receiver yet.'
  279.             endif
  280.                     call vtoc( file(1:length), workf(1:worklen) )
  281. c            print *,' file converted'
  282. c            write(8,*) ' file converted'
  283.                     filedel=.true.  !delete working file when done
  284.                     call sendfile( workf(1:worklen) )
  285.         else    ! not text
  286.             if(.not.batchopt) then
  287.                         print *,' Sending File: ',file(1:length)
  288.             endif
  289.                     call sendfile( file(1:length) )
  290.         endif        
  291.  
  292.     elseif(recvopt) then
  293. c  receive
  294.         if(batchopt) then
  295.             if(firstbatch) then
  296.                print *, ' Receiving BATCH please run sender'
  297.             endif
  298.             if(.not.getfn(filed,leng)) then
  299.                 call ttyout(EOT,1)
  300. c                print *,' All transfers complete.'
  301.                 write(8,*) ' All transfers complete.'
  302.                 close(8,dispose='delete')    ! log file
  303.                 call exit
  304.             endif
  305.             call cleangfn(filed(1:leng),file,length)
  306.         endif
  307.         if(textopt) then
  308.             if(.not.batchopt) then
  309.                         print *,' Receiving Text File: ',file(1:length)
  310.             endif
  311.                     call recvfile( workf(1:worklen) )
  312.                     filedel=.true.  !delete working file when done
  313.                     call ctov( workf(1:worklen), file(1:length) )
  314.         else    ! not text
  315.             if(.not.batchopt) then
  316.                         print *,' Receiving File: ',file(1:length)
  317.             endif
  318.                     call recvfile( file(1:length) )
  319.         endif
  320.     else
  321. c  else bad command
  322. 150            print *,' Invalid XMODEM Command --'
  323.             print *,' Usage: XMODEM  <SRCTB>  <file> '
  324.             print *,'   S = Send, R = Receive, C = Use CRCs, B = Batch'
  325.             print *,'   T = Convert text files to/from CP/M or VAX/VMS'
  326.     endif
  327.  
  328.     if( batchopt ) then
  329.         firstbatch=.false.    ! don't print informational messages
  330.                     ! from now on
  331.         goto 100        ! get next filename
  332.     endif
  333.  
  334. 200     call exit    ! should probably have a unified exit here ??
  335.  
  336.         end
  337. c------------------------------------------------------
  338.     subroutine cleansfn(file,fileclean,length)
  339.     character*(*) file, fileclean
  340.     integer length
  341. c  clean send file name
  342. c  remove too-specific parts of filename (directory and version)
  343. c  and make understandable by CP/M  11 char no dot, last 3 for type
  344.  
  345.     fileclean=' '
  346.     start=index( file,']' )+1
  347.     end=index( file, ';' )-1
  348.     dot = start-1 + index( file(start:end),'.' )    ! VMS guarantees a dot
  349.     if(start.ne.dot) fileclean(1:)=file(start:dot-1)
  350.     if(dot.ne.end) fileclean(9:)=file(dot+1:end)
  351.     ! note: may overwrite last char of vax 9 char filename before dot
  352.     length=11
  353.     return
  354.  
  355.     end
  356.  
  357. c-------------------------------------
  358.     subroutine sendfn(file)
  359.     character*(*) file
  360. c  sends name for batch checksummed send                
  361.  
  362.     byte c
  363.     integer ic
  364.     equivalence (ic,c)
  365.  
  366.         logical ttyinlim
  367.  
  368.         logical crc
  369.         byte checksumbyte
  370.         integer checksum
  371.         common /checks/checksum,crc
  372.         equivalence (checksum,checksumbyte)
  373.  
  374.     parameter BDNMCH=117    ! badname character 'u'
  375.     parameter OKNMCH=6    ! good name character
  376.     parameter ACK=6        ! acknowlege character
  377.     parameter EOF=26    ! filename terminator
  378.  
  379. 100    continue
  380. c    print *,' Awaiting name NAK'
  381. c    write(8,*) ' Awaiting name NAK'
  382.     call waitnlp(80)    ! await NAK
  383.     call ttyout(ACK,1)    ! tell receiver a filename follows
  384.  
  385.     checksum=0
  386. c    print *,file
  387. c    write(8,*) file
  388.     do i=1,len(file)
  389.         c=ichar( file(i:i) )
  390. c        print *, ' filename character=',c
  391. c        write(8,*) ' filename character=',c
  392.         checksum=checksum+c
  393. c        print *,' checksum=',checksum
  394. c        write(8,*) ' checksum=',checksum
  395.         call ttyout(c,1)
  396. 200        if( .not.ttyinlim(c,1,1) ) then
  397. c            print *,' timeout during name'
  398.             write(8,*) ' timeout during name'
  399.             goto 300
  400.         endif
  401. c        print *,' ACK char received decimal=',c
  402. c        write(8,*) ' ACK char received decimal=',c
  403.         if(c.ne.ACK) goto 200    ! let it time out if bad   eat chars ?
  404.     enddo
  405. c    print *,' EOF end of filename'
  406. c    write(8,*) ' EOF end of filename'
  407.     checksum=checksum+EOF
  408.     call ttyout(EOF,1)
  409.     if( .not.ttyinlim(c,1,1) ) then    ! checksum from receiver (MODEM765.ASM
  410.                     ! did not check for timeout)
  411. c        print *,' timeout awaiting checksum in sendfn'
  412.         write(8,*) ' timeout awaiting checksum in sendfn'
  413.         goto 300
  414.     endif
  415.     if( checksumbyte.ne.c ) then
  416. c  bad filename transmission
  417. c        print *,' checksum,byte,c=',checksum,checksumbyte,c
  418.         write(8,*) ' checksum,byte,c='
  419.         write(8,'(3z10)') checksum,checksumbyte,c
  420. 300        continue
  421. c        print *,' BDNMCH = u'
  422. c        write(8,*) ' BDNMCH = u'
  423.         call ttyout(BDNMCH,1)    ! lower case u (but receiver
  424.                     ! only cares that it was not ACK)
  425. c        print *,' receiver better NAK now to start again'
  426.         goto 100
  427.     endif
  428. c    print *,' filename sent ok'
  429. c    write(8,*) ' filename sent ok'
  430.     call ttyout(OKNMCH,1)    ! ACK
  431.     return
  432.     end
  433.  
  434. c---------------------------------------------------------
  435.     subroutine waitnlp(sec)
  436.     integer sec
  437. c  Await NAK, Cancel if not here in sec seconds, or if CAN, ignore garbage
  438.  
  439.     integer count
  440.         logical ttyinlim
  441.     byte c
  442.     parameter NAK=21
  443.     parameter CAN=24
  444.  
  445.     count=0
  446. 100    if( .not.ttyinlim(c,1,1) ) then    ! timeout
  447.         count=count+1
  448. c        print *,' waitnlp passed limit'
  449.         write(8,*) ' waitnlp passed limit'
  450.         if(count.ge.sec) call cancel    ! passed limit
  451.         goto 100
  452.     elseif( c.eq.CAN ) then
  453. c        print *,' waitnlp canceled'
  454.         write(8,*)' waitnlp canceled'
  455.         call cancel
  456.     elseif( c.ne.NAK ) then        ! ignore garbage
  457. c        print *,' waitnlp not NAK, got decimal=',c
  458.         write(8,*) ' waitnlp not NAK, got decimal=',c
  459.         goto 100
  460.     endif
  461. c  must have gotten NAK
  462.     return
  463.  
  464.     end
  465. c---------------------------------------
  466.     logical function getfn(file,length)
  467.     character*(*) file
  468.     integer length
  469. c  get the characters of the batch mode filename  (return false if no more)
  470. c  note: must be declared in callers too.
  471.  
  472.         logical ttyinlim, hsnak
  473.  
  474.     integer ic    ! so char(ic) works
  475.     byte c
  476.  
  477.         logical crc
  478.         byte checksumbyte
  479.         integer checksum
  480.         common /checks/checksum,crc
  481.         equivalence (checksum,checksumbyte)
  482.  
  483.     parameter EOT=4        ! end of batch transfer
  484.     parameter ACK=6        ! acknowledge character
  485.     parameter OKNMCH=6    ! OK name character   ACK
  486.     parameter EOF=26    ! end of filename
  487.  
  488.     getfn=.true.
  489. 100    if( .not.hsnak() ) goto 100    ! may hang 'til CTRL-X
  490.  
  491.     checksum=0
  492.     length=0
  493.     file=' '    ! blank filename
  494. 200    if( .not.ttyinlim(ic,1,1) ) then
  495. c        print *,' Time out receiving filename'
  496.         write(8,*) ' Time out receiving filename'
  497.         goto 100    ! give up and restart handshaking
  498.     endif
  499.     length=length+1
  500.     file(length:length)=char(ic)
  501. c    print *,' filename char=',ic
  502. c    write(8,*) ' filename char=',ic
  503. c    print *,' filename=',file(1:length)
  504. c    write(8,*) ' filename=',file(1:length)
  505.     checksum=checksum+ic
  506.  
  507.     if(ic.eq.EOT) then    ! no more filenames
  508. c        write(8,*) ' getfn got EOT'
  509.         getfn=.false.
  510.         return
  511.     endif
  512.  
  513.     if(ic.eq.EOF) then
  514.         length=length-1
  515. c        print *,' getfn got EOF'
  516. c        write(8,*) ' getfn got EOF'
  517. c        print *,file(1:length)
  518.         write(8,*) file(1:length)
  519.         call ttyout(checksumbyte,1)    ! send calculated checksum
  520.         if(.not.ttyinlim(c,1,1) ) then    ! get verification of checksum
  521.                         ! MODEM765 had no timeout check
  522. c            print *,' timeout awaiting checksum ok'
  523.             write(8,*) ' timeout awaiting checksum ok'
  524.             goto 100    ! restart handshake
  525.         endif
  526.         if(c.eq.OKNMCH) return
  527.  
  528. c        print *,' Checksum error, verification c=',c
  529.         write(8,*) ' Checksum error, verification c=',c
  530.         goto 100    ! restart handshaking
  531.     endif
  532.  
  533.     call ttyout(ACK,1)
  534.  
  535.     if(i.gt.128) then    ! note: match dimension of "file" in main
  536. c        print *,' Too many characters in filename'
  537.         write(8,*) ' Too many characters in filename'
  538.         goto 100    ! start again at NAK
  539.     endif
  540.     goto 200    ! get next char
  541.  
  542.     end
  543.  
  544. c--------------------------------------
  545.     logical function hsnak()
  546. c  true if get ACK in response to NAK, c returns null if timeout  ???
  547. c  note: must be declared in callers too.
  548.  
  549.     byte c
  550.     logical ttyinlim
  551.     parameter ACK=6
  552.     parameter CAN=24
  553.     parameter NAK=21
  554.  
  555.     call ttyout(NAK,1)
  556. c  checking for CAN is the only way to get out of the loop that
  557. c  calls hsnak
  558.     if( .not.ttyinlim(c,1,2) ) then    ! timeout don't care what c is
  559.         write(8,*) ' hsnak timeout'
  560.         hsnak=.false.
  561.     elseif(c.eq.ACK) then
  562.         hsnak=.true.
  563. c        print *,' hsnak got ACK'
  564. c        write(8,*) ' hsnak got ACK'
  565.     elseif(c.eq.CAN) then
  566.         write(8,*) ' hsnak canceled'
  567.         call cancel
  568. c       else    ! bad character, ignore
  569.     endif
  570.     return
  571.  
  572.     end
  573. c------------------------------------------------------
  574.     subroutine cleangfn(file,fileclean,length)
  575.     character*(*) file, fileclean
  576.     integer length
  577. c  clean get file name
  578. c  and make understandable by VAX 13 char with dot, last 3 for type
  579. c  should also replace non-alphanumeric
  580.  
  581.     leng=index(file//' ',' ')-1    ! add blank in case none in filename
  582. c    print *,' leng=',leng
  583.     leng=min(leng,8)    ! in case filename and type run together
  584. c    print *,' leng=',leng
  585.     fileclean(1:)=file(1:leng)//'.'//file(9:)
  586.     length=index(fileclean,' ')-1
  587. c    print *,' length=',length
  588. c    write(8,*) ' cleaned filename VAX form*',fileclean(1:length),'*'
  589.     return
  590.     end
  591. c----------------------------------------------------------------
  592. c  send file
  593.         subroutine sendfile(file)
  594.  
  595. c  declare variables
  596.  
  597.        INTEGER*2 CHAN,STATUS(4)
  598.        COMMON /QIO/ CHAN,STATUS
  599.  
  600.         character*(*) file
  601.  
  602.         byte sectorread(128), sector(130), send(133), c
  603.     equivalence (send(4), sector(1), sectorread(1) )
  604.  
  605.         integer nakwait, stat, ic
  606.         logical ttyinlim
  607.         logical charintime, acked
  608.  
  609.     logical batchopt, firstbatch
  610.     common /batch/batchopt,firstbatch
  611.  
  612.         logical filedel
  613.         common /filest/filedel
  614.  
  615.     integer blocknumber
  616.     byte blockbyte
  617.     equivalence (blocknumber,blockbyte)
  618.  
  619.     integer notblocknumber
  620.     byte notblockbyte
  621.     equivalence (notblocknumber,notblockbyte)
  622.  
  623.         integer errorcount
  624.         common /err/errorcount
  625.  
  626.     integer*4 crctable(16),crclword,lib$crc
  627.         integer*2 highword  ! highword just spaceholder for crclword
  628.     byte highbyte,lowbyte
  629.         common /crcval/crctable,lowbyte,highbyte,highword
  630.     equivalence (lowbyte,crclword)
  631.  
  632. c  sector string descriptor to pass to LIB$CRC
  633.     integer*2 le
  634.     byte ty,cl
  635.     integer*4 ad
  636.     common /sectordescriptor/le,ty,cl,ad    !length,type,class,address
  637.     data le,ty,cl/130,14,1/
  638.  
  639.  
  640. c  obsolete version will be useful for non-VAX versions
  641. c        integer high,low
  642. c    byte highbyte,lowbyte
  643. c        common /crcval/high,low
  644. c    equivalence (high,highbyte)
  645. c    equivalence (low,lowbyte)
  646.  
  647.         logical crc
  648.     byte checksumbyte
  649.         integer checksum
  650.         common /checks/checksum,crc
  651.         equivalence (checksum,checksumbyte)
  652.  
  653.         equivalence (ic,c)
  654.  
  655. c  16 bit negative one for LIB$CRC
  656.     parameter neg1='FFFF'x
  657. c  define ASCII characters
  658.         parameter NUL=0
  659.         parameter SOH=1
  660.         parameter EOT=4
  661.         parameter ACK=6
  662.         parameter NAK=21
  663.         parameter CAN=24
  664.         parameter CRCCHAR='C'
  665. c  timeouts
  666.         parameter respnaklim=10
  667.         parameter naklim=10
  668.         parameter eotlim=10
  669.         parameter errlim=10
  670.  
  671.     ad=%loc(sector)        ! must be assigned dynamically
  672.  
  673.         open(9,name=file,iostat=stat,status='OLD')
  674. c     1         carriagecontrol='NONE',recordtype='FIXED',recl=128)
  675.  
  676.         if(stat) then
  677.         if(.not.batchopt) then
  678.                     print *,'Can''t open ',file,' for send.'
  679.         endif
  680.                 write(8,*) 'Can''t open ',file,' for send.'
  681.                 call cancel
  682.         endif
  683.     if( .not.batchopt ) then
  684.             print *,file,' Open -- Please Run Your Receiver --'
  685.             print *
  686.     endif
  687.         errorcount=0
  688.         blocknumber=1
  689.         nakwait=0
  690.  
  691. c  await first NAK (or 'C') indicating receiver is ready
  692.   200   charintime=ttyinlim(c,1,naklim)         ! return NUL if timeout
  693. c        print *,' first NAK character=',c
  694. c        write(8,*) ' character=',c
  695.         if( .NOT.charintime ) then
  696.         write(8,*) ' initial NAK or C timeout, trying again'
  697.                 nakwait=nakwait+1
  698. c  give the turkey 80 seconds to figure out how to receive a file
  699.                 if(nakwait.ge.80/naklim) call cancel
  700.                 goto 200
  701.         elseif(c.EQ.NAK) then
  702.                 crc=.false.
  703. c        print *,' CHECKSUM mode'
  704.         write(8,*) ' CHECKSUM mode'
  705.         elseif(c.EQ.CRCCHAR) then
  706.                 crc=.true.
  707. c        print *,' CRC mode'
  708.         write(8,*) ' CRC mode'
  709.         elseif(c.EQ.CAN) then
  710.                 call cancel
  711.         else
  712. c  unrecognized character
  713.         write(8,*) 'unrecognized first NAK=',c
  714.                 nakwait=nakwait+1
  715.                 if(nakwait.ge.80/naklim) call cancel
  716.                 goto 200
  717.         endif
  718.  
  719.   300   continue
  720. c  send new sector
  721. c  use equivalence so not need to do inefficient implicit do loop in read
  722.         read(9,1000,end=500) sectorread
  723.  1000   format(128a)
  724.         errorcount=0
  725. c        print *,' sector as read',sector
  726. c        write(8,*) ' sector as read',sector
  727.   400   continue
  728. c  send sector
  729. c        print *,' SOH '
  730. c    write(8,*) ' SOH'
  731.         send(1)=SOH
  732. c  note: equivalence used for fast integer to byte conversion
  733. c        without byte overflow problems
  734.         send(2)=blockbyte
  735.     notblocknumber=not(blocknumber)
  736.         send(3)=notblockbyte
  737. c        print *,' blocknumber=',blocknumber
  738. c        write(8,*) ' blocknumber=',blocknumber
  739.  
  740. c  sector already in sending buffer    done by equivalence
  741.  
  742.         checksum=0
  743. c    call clrcrc
  744. c  calc checksum or crc
  745.         if(crc) then
  746. c        write(8,*) ' CRC mode'
  747. c  put all bytes + two finishing zero bytes through CRC calculation
  748.                 sector(129)=0
  749.                 sector(130)=0
  750.                 crclword=lib$crc( crctable, 0, le ) ! le= sector string descr
  751. c  obsolete version useful for non-VAX version
  752. c                call updcrc( sector,130 )
  753.                 send(132)=highbyte        ! equivalenced to crclword
  754.                 send(133)=lowbyte        ! equivalenced to crclword
  755. c        write(8,*) 'highbyte,lowbyte'
  756. c        write(8,'(2z10)') highbyte,lowbyte
  757. c  actually send
  758.         call ttyout(send,133)
  759.         else
  760. c        write(8,*) 'CHECKSUM mode'
  761.                 do i=1,128
  762.                         checksum=checksum+sector(i)
  763.                 enddo
  764. c  this sends low order byte of checksum
  765.                 send(132)=checksumbyte
  766. c                print *,' checksumbyte ',checksumbyte
  767. c                write(8,*) ' checksumbyte ',checksumbyte
  768.         call ttyout(send,132)
  769.         endif
  770.  
  771. c  sector sent, see if receiver acknowleges
  772. c  getack attempts to get ACK
  773. c  if not, repeat sector
  774. c        print *, ' should wait for ACK 10 seconds'
  775. c        write(8,*) ' should wait for ACK 10 seconds'
  776.  
  777.         call getack(acked)
  778. c        print *, ' getack returned=',acked
  779. c        write(8,*) ' getack returned=',acked
  780.         if(.NOT.acked) goto 400
  781.  
  782. c  ACK received, send next sector
  783.         blocknumber=blocknumber+1
  784.         goto 300
  785.  
  786. c  end of file during read.  finish up sending.
  787.   500   continue
  788.         call ttyout(EOT,1)
  789. c  getack attempts to get ACK up to errlim times
  790.         call getack(acked)
  791.         if( .NOT.acked ) goto 500
  792.  
  793. c        print *,' This file Sending complete.'
  794.         write(8,*) ' This file Sending complete.'
  795.         if (filedel) then
  796.                 close(9,dispose='DELETE')
  797.         else
  798.                 close(9)
  799.         endif
  800.         close(8,dispose='DELETE')    ! the .LOG file
  801.         return
  802.         end
  803.  
  804. c----------------------------------------------------------------
  805. c  receive file
  806.         subroutine recvfile(file)
  807.  
  808. c  declare variables
  809.  
  810.        INTEGER*2 CHAN,STATUS(4)
  811.        COMMON /QIO/ CHAN,STATUS
  812.  
  813.         character*(*) file
  814.         byte c, notc, ck
  815.         integer blocknumber, inotc, notnotc, secbytes, stat
  816.         integer testblock, testprev, ic
  817.         logical ttyinlim
  818.         logical charintime, firstsoh
  819.  
  820.     byte sector(130),sectorwrite(128)
  821.     equivalence (sector,sectorwrite)
  822.  
  823.     logical batchopt,firstbatch
  824.     common /batch/batchopt,firstbatch
  825.  
  826.         integer errorcount
  827.         common /err/errorcount
  828.  
  829.     integer*4 crctable(16),crclword,lib$crc
  830.         integer*2 highword  ! highword just spaceholder for crclword
  831.     byte highbyte,lowbyte
  832.         common /crcval/crctable,lowbyte,highbyte,highword
  833.     equivalence (lowbyte,crclword)
  834.  
  835. c  sector string descriptor to pass to LIB$CRC
  836.     integer*2 le
  837.     byte ty,cl
  838.     integer*4 ad
  839.     common /sectordescriptor/le,ty,cl,ad    !length,type,class,address
  840.     data le,ty,cl/130,14,1/
  841.  
  842.         logical crc
  843.         byte checksumbyte
  844.         integer checksum
  845.         common /checks/checksum,crc
  846.         equivalence (checksum,checksumbyte)
  847.  
  848.         equivalence (ic,c)
  849.  
  850. c  16 bit negative one for LIB$CRC
  851.     parameter neg1='FFFF'x
  852. c  define ASCII characters
  853.         parameter NUL=0
  854.         parameter SOH=1
  855.         parameter EOT=4
  856.         parameter ACK=6
  857.         parameter NAK=21
  858.         parameter CAN=24
  859.         parameter CRCCHAR='C'
  860. c  timeouts
  861.         parameter respnaklim=10
  862.         parameter naklim=10
  863.         parameter eotlim=10
  864.         parameter errlim=10
  865.     parameter datalim=2    ! timeout for data block receive
  866.                 ! 1 second wouldn't work on moderately loaded
  867.                 ! VAX, more may be necessary if heavily loaded
  868.  
  869.     ad=%loc(sector)        ! for sector string descriptor must be dynamic
  870.  
  871.         open(7,name=file,recl=128,status='NEW',iostat=stat,
  872.      1          carriagecontrol='NONE',recordtype='FIXED')
  873.         if(stat) then
  874.         if(batchopt) then
  875.  
  876. c                    print *,' Can''t open ',file,' for receive.'    
  877.                     write(8,*) ' Can''t open ',file,' for receive.'
  878.         else
  879.                     print *,' Can''t open ',file,' for receive.'
  880.                     write(8,*) ' Can''t open ',file,' for receive.'
  881.         endif
  882.         call cancel
  883.         endif
  884.  
  885.     if(.not.batchopt) then
  886.             print *,' Please Send Your File --'
  887.             print *
  888.     endif
  889.  
  890.         if(crc) then
  891.                 secbytes=130
  892.         else            ! checksum mode
  893.                 secbytes=129
  894.         endif
  895.  
  896.         firstsoh=.false.
  897.         errorcount=0
  898.         blocknumber=1
  899.  
  900. c  start the sender by letting ttyinlim time-out in getack routine
  901. c  so it sends a NAK or C
  902.         goto 999
  903.  
  904.   800   continue
  905. c        write(8,*) ' ready for SOH'
  906. c  must allow enough time for other's disk read (xmodem50.asm allows 10sec)
  907.         charintime=ttyinlim(c,1,respnaklim)
  908. c  if no char for a while, try NAK or C again
  909.         if( .NOT.charintime ) then
  910. c                print*,' no response to NAK or C, trying again'
  911.                 write(8,*) ' no response to NAK or C, trying again'
  912.                 goto 999
  913.         endif
  914. c  else received a char so see what it is
  915.         if(c.eq.NUL) goto 800   ! ignore nulls here for compatablity with old
  916.                                 ! versions of modem7
  917.         if(c.EQ.CAN) then
  918. c                print *,' Canceled.  Aborting.'
  919.                 write(8,*) ' Canceled.  Aborting.'
  920.                 call exit
  921.         endif
  922.  
  923. c        print *,' EOT or SOH character=',c
  924. c        write(8,*) ' EOT or SOH character=',c
  925.          if(c.NE.EOT) then
  926.                 IF(c.NE.SOH) then
  927. c                        print *,' Not SOH, was decimal ',c
  928.                         write(8,*) ' Not SOH, was decimal ',c
  929.                         goto 999
  930.                 endif
  931.                 firstsoh=.true.
  932.  
  933. c  character was SOH to indicate start of header
  934. c  get block number and complement
  935.                 charintime=ttyinlim(c,1,1)
  936.         if(.not.charintime) then
  937. c            print *,' timeout awaiting block number'
  938.             write(8,*) ' timeout awaiting block number'
  939.             goto 999
  940.         endif
  941. c                print *,' block=',c
  942. c               write(8,*) ' block=',c
  943.  
  944.                 charintime=ttyinlim(notc,1,1)
  945.         if(.not.charintime) then
  946. c            print *,' timeout awaiting block complement'
  947.             write(8,*) ' timeout awaiting block complement'
  948.             goto 999
  949.         endif
  950. c                print *,' block complement=',notc
  951. c                write(8,*) ' block complement=',notc
  952.                 inotc=notc      ! make integer for "not" function
  953.                 notnotc=iand( not(inotc),255 )  ! mask back to byte
  954.  
  955. c  c is low order byte of ic via equivalence statement
  956.                 if(ic.NE.notnotc) then
  957. c                        print *,' block check bad.'
  958.                         write(8,*) ' block check bad.'
  959.                         goto 999
  960.                 endif
  961. c  block number valid but not yet checked against expected
  962.  
  963. c  clear checksum and CRC
  964.                 checksum=0
  965. c        call clrcrc
  966.  
  967. c  receive the sector and checksum bytes in one call (for speed) and to
  968. c  keep from hogging VAX cpu time at high baud rates.
  969. c  secbytes is 129 for checksum, 130 for CRC
  970.         charintime=ttyinlim(sector,secbytes,datalim)
  971. C check for time out
  972.         if(.not.charintime) then
  973. c            print *,' Timeout on data block read'
  974.             write (8,*) ' Timeout on data block read'
  975.             goto 999
  976.         endif
  977.  
  978.                 if(crc) then
  979. c  put data AND CRC bytes through updcrc
  980.                         crclword=lib$crc(crctable,0,le)    !le=sector string descr
  981. c  obsolete version useful for non-VAX versions
  982. c                        call updcrc(sector,secbytes)
  983.  
  984. c  if result non-zero, BAD.
  985.                         if(highbyte.NE.0 .OR.
  986.      1                     lowbyte.NE.0     ) then
  987. c                                print *,' CRC, high,low='
  988.                                 write(8,*) ' CRC, high,low='
  989. c                                print 3000, highbyte,lowbyte
  990.                                 write(8,3000) highbyte,lowbyte
  991.  3000                           format(2z10)
  992.                                 goto 999
  993.                         endif
  994.                 else
  995. c  don't add received checksum byte to checksum
  996.                         do i=1,secbytes-1
  997.                                 checksum=checksum+sector(i)
  998.                         enddo
  999.                         ck=sector(129)
  1000. c                        print 2100, ck
  1001. c                        write(8,2100) ck
  1002.  
  1003. c                        print 2100, checksum
  1004. c                        write(8,2100) checksum
  1005. c                        print 2100, checksumbyte
  1006. c                        write(8,2100) checksumbyte
  1007. c 2100                   format(' checksum=',z10)
  1008.                          if( checksumbyte.NE.ck ) then
  1009.                                 write(8,*) ' bad checksum'
  1010.                                 goto 999
  1011.                         endif
  1012.                 endif
  1013.  
  1014. c  received OK so we can believe the block number, see which block it was
  1015. c  mask it to be one byte
  1016.                 testblock=iand(blocknumber,255)
  1017.                 testprev=iand( blocknumber-1 ,255)
  1018.                 if( ic.EQ.testprev) then
  1019. c                        print *, ' prev. block again, out of synch'
  1020.                         write(8,*) ' prev. block again, out of synch'
  1021. c  already have this block so don't write it, but ACK anyway to resynchronize
  1022.                         goto 985
  1023.                 elseif( ic.NE.testblock ) then
  1024. c                        print *, ' block number bad.'
  1025.                         write(8,*) ' block number bad.'
  1026.                         goto 999
  1027.                 endif
  1028. c  else was expected block
  1029.  
  1030. c  write before acknowlege so not have to listen while write.
  1031. c  equivalence so not need inefficient implicit do loop
  1032.                 write(7,2000,err=900) sectorwrite
  1033.  2000           format(128a)
  1034.                 goto 975
  1035.  
  1036.   900           write(8,*) ' Can''t write sector. Aborting.'
  1037. c                print *, ' Can''t write sector. Aborting.'
  1038.                 call cancel
  1039.  
  1040.   975           continue
  1041. c  received sector ok, wrote it ok, so acknowlege it to request next.
  1042.                 blocknumber=blocknumber+1
  1043. c  comes here if re-received the previous sector
  1044.   985           continue
  1045.                 errorcount=0
  1046. c                print *, ' ACKing, sector was ok.'
  1047. c                write(8,*) ' ACKing, sector was ok.'
  1048.                 call ttyout(ACK,1)
  1049.                 goto 800
  1050.  
  1051. c  else error so eat garbage in case out of synch and try again
  1052.   999           continue
  1053.                 call eat
  1054. c                print *, ' receive error NAK, block=',blocknumber
  1055.                 write(8,*) ' receive error NAK, block=',blocknumber
  1056.                 if(crc.AND..NOT.firstsoh) then
  1057. c  keep sending 'C'  'til receive first SOH
  1058.                         call ttyout(CRCCHAR,1)
  1059.                 else
  1060.                         call ttyout(NAK,1)
  1061.                 endif
  1062.                 errorcount=errorcount+1
  1063.   998           if(errorcount.GE.errlim) then
  1064. c                        print *,' Unable to receive block. Aborting.'
  1065.                         write(8,*) ' Not receive block. Aborting.'
  1066. c  delete incompletely received file
  1067.                         close(7,dispose='DELETE')
  1068.                         call cancel
  1069.                 endif
  1070. c  retry
  1071.                 goto 800
  1072.         endif
  1073.  
  1074. c  EOT received instead of SOH so file done.
  1075. c  should keep sending ACK 'til no more EOT's ?
  1076.         close(9)
  1077.         close(7)
  1078.         call ttyout(ACK,1)
  1079.         call ttyout(ACK,1)
  1080.         call ttyout(ACK,1)
  1081.  
  1082.         write(8,*) ' Completed.'
  1083. c       print *,   ' Completed.'
  1084. c  transfer ok, so delete the error log file.
  1085.         close(8,dispose='DELETE')
  1086.         return
  1087.         end
  1088.  
  1089. c-------------------------------------------------------------
  1090.         subroutine ctov(input,output)
  1091. c  convert file of XMODEM 128 byte records with embedded <CR><LF>
  1092. c  marking end-of-line and CTRL-Z marking end-of-file
  1093. c  to carriage-control=LIST (normal VAX editable file)
  1094.  
  1095.         character*80 input,output
  1096.         character*300 line
  1097.         character*1 CR,LF,recchar
  1098.         logical eof, eol
  1099.     integer len
  1100.  
  1101.         logical filedel
  1102.         common /filest/filedel
  1103.  
  1104.     len=0
  1105.     eof=.false.
  1106.     eol=.false.
  1107.         CR=char(13)
  1108.         LF=char(10)
  1109.  
  1110.         open(9,file=input,status='OLD')
  1111. c  set maximum output record length to 300 (fortran default is 133)
  1112.         open(7,file=output,status='NEW',carriagecontrol='LIST',recl=300)
  1113.  
  1114. c  getchar (read new record if no input characters left)
  1115. c  if EOF on input, write line and exit
  1116. c  if CR then
  1117. c    if getchar LF then write line
  1118. c    else put back char and putchar CR into line (error if too long)
  1119. c    endif
  1120. c  else putchar (write error message if line too long)
  1121. c  endif
  1122. c  loop
  1123.  
  1124.   100   call getc(recchar,eof,eol)
  1125.         if(eof) goto 200
  1126.         if(recchar.eq.CR) then
  1127. c           PRINT *,' CR'
  1128.                 call getc(recchar,eof)
  1129.                 if(eof.or.recchar.ne.LF) then
  1130.                         call putback
  1131.  
  1132.                         len=len+1
  1133.                         if(len.ge.301) print *,' Out line too long.'
  1134. c               print *,' too long line=',line
  1135.                         line(len:len)=recchar
  1136.                 else
  1137. c  was LF
  1138. c               PRINT *,' LEN=',LEN
  1139. c               print *,' after LF, line=',line(1:len)
  1140.                         write(7,2000) line(1:len)
  1141.                         len=0
  1142.                 endif
  1143.         else
  1144. c  not CR, was "ordinary" character
  1145.                 len=len+1
  1146.                 if(len.ge.301) then
  1147.                         print *,' Out line too long.'
  1148. c                       PRINT *,' LINE=',LINE(1:len)
  1149.         else
  1150.                     line(len:len)=recchar
  1151.                 endif
  1152.         endif
  1153.  
  1154.         go to 100
  1155.  
  1156. c  flush last line and exit
  1157.   200   continue
  1158.         if(len.gt.0) then
  1159.                 write(7,2000) line(1:len)
  1160.  2000           format(a)
  1161.         len=0
  1162.         endif
  1163.         if (filedel) then
  1164.                 close(9,dispose='DELETE')
  1165.         else
  1166.                 close(9)
  1167.         endif
  1168.         close(7)
  1169.         return
  1170.         end
  1171. c------------------------------------------
  1172.         subroutine getc(c,eof)
  1173.         character*1 c
  1174.         logical eof
  1175. c  get character from a CP/M text file
  1176. c  point to next character in record (read record if necessary)
  1177.         character*1 CTRLZ
  1178.  
  1179.         integer point
  1180.         character*128 record
  1181.         common /reccom/point,record
  1182.         data point/0/
  1183.  
  1184.         logical firsttime
  1185.     common /getccom/firsttime
  1186.         data firsttime/.true./
  1187.  
  1188.         CTRLZ=char(26)
  1189.         point=point+1
  1190.         if( firsttime .or. (point.gt.128) ) then
  1191.                 firsttime=.false.
  1192.   100           read(9,1000,end=200) record
  1193.  1000           format(a)
  1194. c               PRINT *,RECORD
  1195.                 point=1
  1196.         endif
  1197. c  strip parity in case CP/M file had it
  1198.         c=char(iand(ichar(record(point:point)),127))
  1199.         if(c.eq.CTRLZ) goto 200        ! end of CP/M text file
  1200.     return
  1201.  
  1202. c  end of file
  1203.   200   eof=.true.
  1204.     firsttime=.true.    ! ready for next file
  1205.     point=0
  1206.         return
  1207.         end
  1208. c----------------------------------------------
  1209.     subroutine putback
  1210. c  point to previous input character so this character will be getchar result
  1211. c  even works if 1st char of record
  1212.     integer point
  1213.     character*128 record
  1214.     common /reccom/point,record
  1215.  
  1216.     point=point-1
  1217.     return
  1218.     end
  1219. c-------------------------------------------------------------
  1220.         subroutine vtoc(input,output)
  1221. c  convert VAX text file to
  1222. c  file of XMODEM 128 byte records with embedded <CR><LF>
  1223.  
  1224.         character*80 input,output
  1225.         character*1 CR,LF,c
  1226.         logical eof,eol
  1227.  
  1228.     eof=.false.
  1229.     eol=.false. 
  1230.         CR=char(13)
  1231.         LF=char(10)
  1232.  
  1233.         open(9,file=input,status='OLD',READONLY)
  1234.         open(7,file=output,status='NEW',carriagecontrol='LIST',
  1235.      1                               recl=128,recordtype='FIXED')
  1236.  
  1237. c  getchar (read new line if no input characters left)
  1238. c  putchar ( output record if full, close if EOF )
  1239. c  if EOL on input, putchar CR putchar LF (output record if full)
  1240. c  loop
  1241.  
  1242.   100   call getv(c,eof,eol)
  1243.         if(.not.eol) then
  1244.                 call putchar(c,eof)
  1245.                 if(eof) then
  1246.                         return
  1247.                 endif
  1248.         else
  1249. c  end of line
  1250.                 call putchar(CR,eof)
  1251.                 call putchar(LF,eof)
  1252.                 eol=.false.
  1253.                 if(eof) then
  1254.                         return
  1255.                 endif
  1256.         endif
  1257.         go to 100
  1258.  
  1259.         end
  1260. c------------------------------------------
  1261.         subroutine putchar(c,eof)
  1262.         character*1 c
  1263.         logical eof
  1264. c  put character into record (write record if necessary)
  1265. c  if eof, fills out rest of record with CTRL-Z's and exits
  1266.         character*1 CTRLZ
  1267.  
  1268.         integer point
  1269.         character*128 record
  1270.         common /reccom/point,record
  1271.         data point/0/
  1272.  
  1273.         if(eof) goto 200
  1274.         point=point+1
  1275. c  strip parity in case VAX file had it
  1276.         record(point:point)=char(iand(ichar(c),127))
  1277. c       print *,' record(point:point)=',record(point:point)
  1278. c       print *,' point=',point
  1279.    50   if(point.ge.128) then
  1280. c               print *,' record=',record
  1281.   100           write(7,1000) record
  1282.  1000           format(a)
  1283.                 point=0
  1284.         endif
  1285.         return
  1286.  
  1287. c  EOF fill record with 26's (CTRL-Z, CP/M end of file mark for ASCII)
  1288. c  output last record and exit
  1289.   200   continue
  1290. c       print *,' in putchar EOF section'
  1291.         CTRLZ=char(26)
  1292.         do i=point+1,128
  1293.                 record(i:i)=CTRLZ
  1294.         enddo
  1295. c       print *,' record=',record
  1296.         write(7,1000) record
  1297.         close(9)
  1298.         close(7)
  1299.     point=0        ! ready for next file
  1300.         return
  1301.         end
  1302. c-------------------------------------------
  1303.         subroutine getv(inchar,eof,eol)
  1304.         character*1 inchar
  1305.         logical eof,eol
  1306. c  get character from input line (read line if necessary)
  1307. c  returns character and eol=.true. if no more char on line
  1308. c  returns eof if end of file (no character)
  1309.         character*255 line
  1310.         integer len, pos
  1311.         logical firsttime
  1312.         common/lincom/pos,len,line
  1313.         data pos/0/
  1314.  
  1315.         if(pos.eq.0) then
  1316.                 read(9,1000,end=100)len,line(1:len)
  1317.  1000           format(q,a)
  1318. c               print *,' line=',line
  1319.         endif
  1320.         pos=pos+1
  1321.         if(pos.gt.len) then
  1322.                 eol=.true.
  1323.                 pos=0
  1324.                 return
  1325.         endif
  1326. c       print *,' pos=',pos,' line(1:pos)=',line(1:pos)
  1327. c       print *,' line(pos:pos)=',line(pos:pos)
  1328.         inchar=line(pos:pos)
  1329. c       print *,' pos,char',pos,inchar
  1330.         return
  1331. c  EOF
  1332.   100    continue
  1333.     eof=.true.
  1334.     return
  1335.     end
  1336. cc-----------------------------------------------------------
  1337. c    subroutine clrcrc
  1338. cc  clears CRC
  1339. c       integer high,low
  1340. c    byte highbyte,lowbyte
  1341. c       common /crcval/high,low
  1342. c    equivalence (high,highbyte)
  1343. c    equivalence (low,lowbyte)
  1344. c
  1345. c    high=0
  1346. c    low=0
  1347. c    return
  1348. c    end
  1349. cc-----------------------------------------------------------
  1350. c    subroutine updcrc(bbyte,n)
  1351. c    byte bbyte(*)
  1352. c    integer n
  1353. cc  updates the Cyclic Redundancy Code
  1354. cc  uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
  1355. cc    and as used by CRCSUBS version 1.20 for 8080 microprocessor
  1356. cc    and incorporated into the MODEM7 protocol of the CP/M user's group
  1357. c
  1358. cc  during sending:
  1359. cc  call clrcrc
  1360. cc  call updcrc   for each byte
  1361. cc  call fincrc   to finish (or just put 2 extra zero bytes through updcrc)
  1362. cc  result to send is low byte of high and low in that order.
  1363. c
  1364. cc  during reception:
  1365. cc  call clrcrc
  1366. cc  call updcrc   all bytes PLUS the two received CRC bytes must be passed
  1367. cc       to this routine
  1368. cc       then zero in high and low means good checksum
  1369. c
  1370. cc  see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
  1371. c
  1372. cc  must declare integer to allow shifting
  1373. c    integer byte
  1374. c    integer bit,bitl,bith
  1375. c
  1376. c        integer high,low
  1377. c    byte highbyte,lowbyte
  1378. c        common /crcval/high,low
  1379. c    equivalence (high,highbyte)
  1380. c    equivalence (low,lowbyte)
  1381. c
  1382. cc    write(8,*) ' inside updcrc'
  1383. c    do i=1,n
  1384. cc        write(8,*) 'high,low,byte'
  1385. cc        write(8,1000) high,low,bbyte
  1386. cc1000        format(3z10)
  1387. c        byte=bbyte(i)
  1388. c
  1389. c        do j=1,8
  1390. cc  get high bits of bytes so we don't lose them when shift
  1391. cc  positive is left shift
  1392. c            bit =ishft( iand(128,byte), -7)
  1393. c            bitl=ishft( iand(128,low),  -7)
  1394. c            bith=ishft( iand(128,high), -7)
  1395. cc            write(8,*) 'bit,bitl,bith'
  1396. cc            write(8,1000) bit,bitl,bith
  1397. cc  get ready for next iteration
  1398. c            newbyte=ishft(byte,1)
  1399. c            byte=newbyte        ! introduced dummy variable newbyte
  1400. c                        ! to avoid "access violation"
  1401. cc            write(8,*) ' byte ready for next iteration'
  1402. cc            write(8,1000) byte
  1403. cc  shift those bits in
  1404. c            low =ishft(low ,1)+bit
  1405. c            high=ishft(high,1)+bitl
  1406. cc            write(8,*),' high,low after shifting bits in'
  1407. cc            write(8,1000) high,low 
  1408. c
  1409. c            if(bith.eq.1) then
  1410. c                high=ieor(16,high)
  1411. c                low=ieor(33,low)
  1412. cc                write(8,*) ' high,low  after xor'
  1413. cc                write(8,1000) high,low
  1414. c            endif
  1415. c        enddo
  1416. c    enddo
  1417. c        return
  1418. c        end
  1419. c-----------------------------------------------------------
  1420. c    subroutine fincrc
  1421. c  finish CRC calculation for sending    result in high, low
  1422. c  NEVER ACTUALLY USED.  I JUST PASS ZEROES TO UPDCRC.
  1423. c  merely runs updcrc with two  zero bytes
  1424. c       integer high,low
  1425. c       byte highbyte,lowbyte
  1426. c       common /crcval/high,low
  1427. c    equivalence (high,highbyte)
  1428. c    equivalence (low,lowbyte)
  1429. c
  1430. c    byte=0
  1431. c    call updcrc(byte)
  1432. c    call updcrc(byte)
  1433. c    return
  1434. c    end
  1435. c-----------------------------------------------------------
  1436.     subroutine eat
  1437. c  eats extra characters 'til 1 second pause   used to re-synch after error
  1438.     byte buffer(135)
  1439.     integer numchar
  1440.     logical i,ttyinlim
  1441. c
  1442.     parameter maxtime=1
  1443. c  in case mis-interpreted header, allow at least 1 block of garbage
  1444.     numchar=135
  1445.  
  1446.     i=ttyinlim(buffer,numchar,maxtime)
  1447. c    print *,' finished eating'
  1448. c    write(8,*) ' finished eating'
  1449.     return
  1450.     end
  1451. c-----------------------------------------------------------
  1452.       LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
  1453.       BYTE LINE(*)
  1454.       INTEGER N,LIMIT
  1455. C              READ CHARACTERS FROM TERMINAL 
  1456. C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
  1457. C              RECEIVED FOR LIMIT SECONDS
  1458. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
  1459. C              MAY HAVE PROBLEM WITH TYPE-AHEAD 
  1460. c    apparent typeahead problem:  in SENDFN, remote can send checksum
  1461. c    too soon after we send EOF, it is seen by typeahead since
  1462. c    this routine has not yet activated, so high bit already stripped
  1463. c       This was solved by using PASSALL routine.
  1464.  
  1465.        INTEGER*2 CHAN,STATUS(4)
  1466.        COMMON /QIO/ CHAN,STATUS
  1467.  
  1468.       INCLUDE '($SSDEF)'    ! defines error status returns
  1469.       INTEGER I
  1470.       INTEGER SYS$QIOW
  1471.       INTEGER*4 terminators(2)
  1472.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  1473.       DATA TERMINATORS/0,0/
  1474. C 
  1475. c    write(8,*) ' inside ttyinlim'
  1476.       TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
  1477.       I = SYS$QIOW(,           !EVENT FLAG
  1478.      -              %VAL(CHAN),         !CHANNEL
  1479.      -              %VAL(%LOC(IO$_TTYREADALL).OR. 
  1480.      -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
  1481.      -              STATUS,,,
  1482.      -              LINE,       !BUFFER
  1483.      -              %VAL(N),   !LENGTH
  1484.      -              %VAL(LIMIT),    !time limit in seconds
  1485.      -              terminators,,)  !no terminators 
  1486. c      print *,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  1487. c      write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  1488.       if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  1489.          TTYINLIM=.FALSE.
  1490. c         print *, ' ttyinlim timeout'
  1491.          write(8,*) ' ttyinlim timeout'
  1492.          return
  1493.       ENDIF
  1494.  
  1495.       IF (I) THEN
  1496. c         print *, ' returning from ttyinlim'
  1497. c         write(8,*) ' returning from ttyinlim
  1498.          return
  1499.       endif
  1500. C 
  1501. C              ERROR
  1502.       write(8,*) ' ttyinlim error.'
  1503.       CALL SYS$EXIT( %VAL(I) )
  1504.       END 
  1505. c-----------------------------------------------------------
  1506.       SUBROUTINE TTYOUT(LINE,N) 
  1507.       BYTE LINE(*)
  1508.       INTEGER*2 N
  1509. C  output N characters without interpretation
  1510.  
  1511.        INTEGER*2 CHAN,STATUS(4)
  1512.        COMMON /QIO/ CHAN,STATUS
  1513.  
  1514.       INTEGER I 
  1515.       INTEGER SYS$QIOW
  1516.       EXTERNAL IO$M_NOFORMAT
  1517.       EXTERNAL IO$_WRITEVBLK
  1518. C 
  1519.       IF( N.LE.0 ) THEN
  1520.          WRITE(8,*) ' ttyout called with strange number of char ',N
  1521.          RETURN
  1522.       ENDIF
  1523. C 
  1524. c    print *, ' to be sent by ttyout ', (line(i),i=1,n)
  1525. c    write(8,*) ' to be sent by ttyout ', (line(i),i=1,n)
  1526.       I = SYS$QIOW(,
  1527.      -              %VAL(CHAN), 
  1528.      -              %VAL(%LOC(IO$_WRITEVBLK).OR.
  1529.      -                   %LOC(IO$M_NOFORMAT)),
  1530.      -              STATUS,,, 
  1531.      -              LINE, 
  1532.      -              %VAL(N),, 
  1533.      -              %VAL(0),, )         !NO CARRIAGE CONTROL 
  1534.       if(I) then
  1535.          return
  1536.       endif
  1537. C 
  1538. C              ERROR
  1539.       write(8,*) ' ttyout error.'
  1540.       CALL SYS$EXIT( %VAL(I) )
  1541.       END
  1542. c--------------------------------------------------
  1543.     subroutine giveup
  1544. c  this exit routine used especially in case exited via QIO problem
  1545.  
  1546.        INTEGER*2 CHAN,STATUS(4)
  1547.        COMMON /QIO/ CHAN,STATUS
  1548.  
  1549. c  note: if want log file message, must re-open since
  1550. c  system already closed all files before this exit handler got control
  1551. c    open(8,file='XMODEM.LOG',access='APPEND')
  1552. c    write(8,*) ' Exit handler.'
  1553.  
  1554. c  turn off passall
  1555.     call passall(CHAN,.FALSE.)
  1556.     return
  1557.     end
  1558. c-----------------------------------------------------
  1559.     SUBROUTINE PASSALL(CHAN,SWITCH)
  1560. C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
  1561.     IMPLICIT INTEGER (A-Z)
  1562.     INCLUDE '($TTDEF)'
  1563.     INCLUDE '($IODEF)'
  1564.     LOGICAL SWITCH
  1565.     COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH    !byte reversed LENGTH
  1566.     BYTE CLASS,TYPE,CHARAC,LENGTH
  1567.     INTEGER*2 WIDTH,SPEED
  1568.     EQUIVALENCE(CHARACTER,CHARAC)
  1569.  
  1570. c  sense current terminal driver mode
  1571.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
  1572.     1 CLASS,,,,,)
  1573.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
  1574.  
  1575.     IF(SWITCH) THEN
  1576. c  turn on 8 bit passall
  1577.         CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
  1578.     1                TT$M_EIGHTBIT
  1579.     ELSE
  1580. c  turn off 8 bit passall
  1581.         CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
  1582.     1                               .NOT.TT$M_EIGHTBIT
  1583.     ENDIF
  1584.     SPEED=0    !LEAVE SPEED UNCHANGED
  1585.     PAR=0    !LEAVE PARITY UNCHANGED
  1586.  
  1587. c  set terminal mode with desired passall
  1588.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
  1589.     1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
  1590.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
  1591.     RETURN
  1592.     END
  1593. c---------------------------------------------------
  1594.     SUBROUTINE ERROR(STRING,MSGID)
  1595. c        Types error message
  1596.     IMPLICIT INTEGER(A-Z)
  1597.     CHARACTER*(*) STRING
  1598.     CHARACTER*80 MESSAGE
  1599.  
  1600.     TYPE *,' *** ERROR: ',STRING
  1601.     write(8,*) ' *** ERROR: ',STRING
  1602.     CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
  1603.     TYPE *,MESSAGE(1:MSGLEN),CRLF
  1604.     write(8,*) MESSAGE(1:MSGLEN),CRLF
  1605.     RETURN
  1606.     END
  1607. c-----------------------------------------------------------
  1608.     subroutine cancel
  1609.  
  1610.        INTEGER*2 CHAN,STATUS(4)
  1611.        COMMON /QIO/ CHAN,STATUS
  1612.  
  1613. c  called to cancel send (at least)
  1614.     logical ttyinlim
  1615.     byte c(135)        ! enough space to eat everything
  1616.     parameter CAN=24
  1617.     parameter SPACE=32
  1618.  
  1619. c  eat garbage
  1620.   100    if( ttyinlim(c,135,1) ) goto 100
  1621. c  cancel other end
  1622.     call ttyout(CAN,1)
  1623.  
  1624. c  eat garbage again in case it didn't understand ?
  1625.   200    if( ttyinlim(c,135,1) ) goto 200
  1626. c  clear the CAN from far end's input in case he has already cancelled and so
  1627. c    has not yet read it.
  1628. c      ???? why ? xmodem50.asm does it
  1629.  
  1630.     call ttyout(SPACE,1)
  1631.  
  1632. c    print*,' XMODEM program canceled'
  1633.     write(8,*)' XMODEM program canceled'
  1634.     call exit
  1635.     end
  1636. c------------------------------------------------------
  1637.     subroutine getack(acked)
  1638. c  returns .TRUE. if gets ACK 
  1639.     logical charintime, ttyinlim, acked
  1640.     byte sector(130),c
  1641.  
  1642.     integer errorcount
  1643.     common /err/errorcount
  1644.  
  1645.     parameter ACK=6
  1646.     parameter NAK=21
  1647.     parameter CAN=24
  1648.     parameter errlim=10    ! max number of errors
  1649.     parameter acklim=15    ! seconds to wait for ACK (xmodem.asm uses 10?)
  1650.                 ! but Stern's Northstar takes longer
  1651.                 ! to write 128 sectors
  1652.  
  1653. c    print*,' inside getack'
  1654. c    write(8,*) ' inside getack'
  1655. c  empty typeahead in case garbage
  1656. c    charintime=ttyinlim(sector,130,0)
  1657.  
  1658. c  allow time for disk file write at other end.  Typically 128 sectors.
  1659. c                        Sometimes only 1 track.
  1660. 10    charintime=ttyinlim(c,1,acklim)
  1661. c    print*,' getack got',c
  1662. c    write(8,*) ' getack got',c
  1663.  
  1664.     if( .NOT.charintime ) then
  1665. c        print *, ' timeout in GETACK'        
  1666.         write(8,*) ' timeout in GETACK'        
  1667.         errorcount=errorcount+1
  1668.         if(errorcount.GE.errlim) then
  1669.             write(8,*) ' not acknowleged in 10 tries.'
  1670. c            print *,' Can''t send sector. Aborting.'
  1671.             call cancel
  1672.         endif
  1673.         goto 10        ! try again
  1674.     elseif( c.EQ.ACK ) then
  1675. c  received ACK
  1676.         acked=.TRUE.
  1677.     elseif( c.EQ.NAK ) then
  1678.         print *,' not ACK, decimal=',c
  1679.         write(8,*) ' not ACK, decimal=',c
  1680.         errorcount=errorcount+1
  1681.         if(errorcount.GE.errlim) then
  1682.             write(8,*) ' not acknowleged in 10 tries.'
  1683. c            print *,' Can''t send sector. Aborting.'
  1684.             call cancel
  1685.         endif
  1686.         acked=.FALSE.
  1687.  
  1688.     elseif(c.EQ.CAN) then 
  1689.         write (8,*) 'Cancel received while waiting for ACK'
  1690.         call cancel
  1691.     else
  1692. c  received garbage, ignore it and try again.
  1693. c  note: this risks seeing ACK inside the burst of garbage, possibly should EAT
  1694. c        print *, ' not ACK, decimal=',c
  1695.         write(8,*) ' not ACK, decimal=',c
  1696.         goto 10
  1697.     endif
  1698.     return
  1699.     end
  1700.